! This file is part of xtb.
!
! Copyright (C) 2017-2020 Stefan Grimme
!
! xtb is free software: you can redistribute it and/or modify it under
! the terms of the GNU Lesser General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! xtb is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public License
! along with xtb.  If not, see <https://www.gnu.org/licenses/>.

module xtb_printout
   use xtb_mctc_accuracy, only : wp, sp
   implicit none

   interface prelemdata_inc
      module procedure prelemdata_inc_real
      module procedure prelemdata_inc_int
      module procedure prelemdata_inc_real_array
      module procedure prelemdata_inc_int_array
      module procedure prelemdata_inc_string
   end interface prelemdata_inc

   interface prelemdata
      module procedure prelemdata_real
      module procedure prelemdata_int
      module procedure prelemdata_real_array
      module procedure prelemdata_int_array
      module procedure prelemdata_string
   end interface prelemdata

contains

subroutine prelemparam(globpar)
   !  use iso_fortran_env, only : id => output_unit
   use xtb_mctc_timings, only : prtimestring
   use xtb_mctc_symbols, only : toSymbol
   use xtb_aoparam
   implicit none
   real(wp),intent(in) :: globpar(25)
   integer :: id
   integer :: i,j
   integer,parameter :: max_elem = 94

   call open_file(id,'param','w')
   write(id,'("!!",1x,72("="))') ! print a warning, to keep folk from editing
   write(id,'("!! this file is automatically generated, DO NOT EDIT HERE")')
   write(id,'("!! but use an appropiate tool to generate it anew")')

   write(id,'("subroutine copy_NAME_parameterset(globpar)")')
   write(id,'("use iso_fortran_env, wp => real64")')
   write(id,'("!use xtb_aoparam, only: tb_parameter, &")')
   write(id,'("!                   kpair,en,mc,gam,gam3,rad,wll,rep,polyr,cxb, &")')
   write(id,'("!                   ao_exp,ao_lev,ao_pqn,ao_l,ao_typ,lpar,kcnat,&")')
   write(id,'("!                   radaes,dpolc,qpolc,ao_n,metal,cnval,timestp")')
   write(id,'("implicit none")')
   write(id,'("real(wp),intent(out) :: globpar(25)")')
   write(id,'("integer :: i,j")')
   write(id,'("type(tb_parameter),dimension(max_elem) :: atomparameter")')
   do i = 1, max_elem
      write(id,'("data atomparameter(",i0,") / tb_parameter( & !",1x,a)') &
         &  i,toSymbol(i)
      call prelemdata_inc(id,'en',en(i))
      call prelemdata_inc(id,'mc',mc(i))
      call prelemdata_inc(id,'gam',gam(i))
      call prelemdata_inc(id,'gam3',gam3(i))
      call prelemdata_inc(id,'rad',rad(i))
      call prelemdata_inc(id,'wll',wll(i,:))
      call prelemdata_inc(id,'rep',rep(:,i))
      call prelemdata_inc(id,'polyr',polyr(:,i))
      call prelemdata_inc(id,'cxb',cxb(i))
      call prelemdata_inc(id,'ao_exp',ao_exp(:,i))
      call prelemdata_inc(id,'ao_lev',ao_lev(:,i))
      call prelemdata_inc(id,'lpar',lpar(:,i))
      call prelemdata_inc(id,'kcnat',kcnat(:,i))
      call prelemdata_inc(id,'radaes',radaes(i))
      call prelemdata_inc(id,'dpolc',dpolc(i))
      call prelemdata_inc(id,'qpolc',qpolc(i))
      call prelemdata_inc(id,'ao_pqn',ao_pqn(:,i))
      call prelemdata_inc(id,'ao_l',ao_l(:,i))
      call prelemdata_inc(id,'ao_n',ao_n(i))
      call prelemdata_inc(id,'ao_typ',ao_typ(:,i))
      call prelemdata_inc(id,'metal',metal(i))
      call prelemdata_inc(id,'cnval',cnval(i))
      ! print at the end, because it closes the parameter block (this is a hack)
      call prelemdata_inc(id,'timestp',timestp(i))
   enddo

   write(id,'("globpar = (/ &")')
   write(id,'(3x,5(g0,"_wp, "),"&")')        (globpar(i),i= 1, 5)
   write(id,'(3x,5(g0,"_wp, "),"&")')        (globpar(i),i= 6,10)
   write(id,'(3x,5(g0,"_wp, "),"&")')        (globpar(i),i=11,15)
   write(id,'(3x,5(g0,"_wp, "),"&")')        (globpar(i),i=16,20)
   write(id,'(3x,4(g0,"_wp, "),g0,"_wp /)")') (globpar(i),i=21,25)

   write(id,'("kpair = 1.0_wp")')
   do i = 1, max_elem
      do j = 1, max_elem
         if (abs(kpair(j,i)-1.0_wp).gt.1.0e-5_wp) then
            write(id,'("kpair(",i0,",",i0,") = ",1x,g0,"_wp")') &
               j,i,kpair(j,i)
         endif
      enddo
   enddo

   write(id,'("en(1:94)          = atomparameter % en")')
   write(id,'("mc(1:94)          = atomparameter % mc")')
   write(id,'("gam(1:94)         = atomparameter % gam")')
   write(id,'("gam3(1:94)        = atomparameter % gam3")')
   write(id,'("rad(1:94)         = atomparameter % rad")')
   write(id,'("do i = 1,10")')
   write(id,'("   wll(1:94,i)    = atomparameter % wll(i)")')
   write(id,'("enddo")')
   write(id,'("rep(1,1:94)       = atomparameter % rep(1)")')
   write(id,'("rep(2,1:94)       = atomparameter % rep(2)")')
   write(id,'("do i = 1,4")')
   write(id,'("   polyr(i,1:94)   = atomparameter % polyr(i)")')
   write(id,'("enddo")')
   write(id,'("cxb(1:94)         = atomparameter % cxb")')
   write(id,'("do i = 1,10")')
   write(id,'("   ao_exp(i,1:94) = atomparameter % ao_exp(i)")')
   write(id,'("   ao_lev(i,1:94) = atomparameter % ao_lev(i)")')
   write(id,'("   ao_pqn(i,1:94) = atomparameter % ao_pqn(i)")')
   write(id,'("   ao_l(i,1:94)   = atomparameter % ao_l(i)")')
   write(id,'("   ao_typ(i,1:94) = atomparameter % ao_typ(i)")')
   write(id,'("enddo")')
   write(id,'("do i = 0,2")')
   write(id,'("   lpar(i,1:94)   = atomparameter % lpar(i)")')
   write(id,'("   kcnat(i,1:94)  = atomparameter % kcnat(i)")')
   write(id,'("enddo")')
   write(id,'("radaes(1:94)      = atomparameter % radaes")')
   write(id,'("dpolc(1:94)       = atomparameter % dpolc")')
   write(id,'("qpolc(1:94)       = atomparameter % qpolc")')
   write(id,'("ao_n(1:94)        = atomparameter % ao_n")')
   write(id,'("metal(1:94)       = atomparameter % metal")')
   write(id,'("cnval(1:94)       = atomparameter % cnval")')
   write(id,'("timestp(1:94)     = atomparameter % timestp")')

   write(id,'("end subroutine copy_NAME_parameterset")')
   write(id,'("!!",1x,72("="))')
   write(id,'("!! generated by prelemparam in printout.f90 from libxtb.a on",1x,a)') &
   prtimestring('N')
   call close_file(id)

end subroutine prelemparam

subroutine prelemdata_string(id,name,data)
   implicit none
   integer,intent(in) :: id
   character(len=*),intent(in) :: name
   character(len=*),intent(in) :: data
   write(id,'(3x,a,1x,"=",1x)',advance='no') name
   write(id,'("''",a,"''")',advance='no') data
   write(id,'(")/")')
end subroutine prelemdata_string

subroutine prelemdata_int(id,name,data)
   implicit none
   integer,intent(in) :: id
   character(len=*),intent(in) :: name
   integer,intent(in) :: data
   write(id,'(3x,a,1x,"=",1x)',advance='no') name
   write(id,'(i0)',advance='no') data
   write(id,'(", &")')
end subroutine prelemdata_int

subroutine prelemdata_real(id,name,data)
   implicit none
   integer,intent(in) :: id
   character(len=*),intent(in) :: name
   real(wp),intent(in) :: data
   write(id,'(3x,a,1x,"=",1x)',advance='no') name
   write(id,'(g0,"_wp")',advance='no') data
   write(id,'(", &")')
end subroutine prelemdata_real

subroutine prelemdata_int_array(id,name,data)
   implicit none
   integer,intent(in) :: id
   character(len=*),intent(in) :: name
   integer,intent(in) :: data(:)
   integer :: i
   write(id,'(3x,a,1x,"=",1x,"(/")',advance='no') name
   do i = 1, size(data,1)-1
      write(id,'(i0,",",1x)',advance='no') data(i)
   enddo
   write(id,'(i0)',advance='no') data(size(data,1))
   write(id,'("/), &")')
end subroutine prelemdata_int_array

subroutine prelemdata_real_array(id,name,data)
   implicit none
   integer,intent(in) :: id
   character(len=*),intent(in) :: name
   real(wp),intent(in) :: data(:)
   integer :: i
   write(id,'(3x,a,1x,"=",1x,"(/")',advance='no') name
   do i = 1, size(data,1)-1
      write(id,'(g0,"_wp",",",1x)',advance='no') data(i)
   enddo
   write(id,'(g0,"_wp")',advance='no') data(size(data,1))
   write(id,'("/), &")')
end subroutine prelemdata_real_array

subroutine prelemparam_inc(globpar)
   !  use iso_fortran_env, only : id => output_unit
   use xtb_mctc_timings, only : prtimestring
   use xtb_mctc_symbols, only : toSymbol
   use xtb_aoparam
   implicit none
   real(wp),intent(in) :: globpar(25)
   integer :: id
   integer :: i,j
   integer,parameter :: max_elem = 94

   call open_file(id,'param','w')
   write(id,'("!!",1x,72("="))') ! print a warning, to keep folk from editing
   write(id,'("!! this file is automatically generated, DO NOT EDIT HERE")')
   write(id,'("!! but use an appropiate tool to generate it anew")')

   write(id,'("data NAME_globparameter / &")')
   write(id,'(3x,5(g0,"_wp, "),"&")')        (globpar(i),i= 1, 5)
   write(id,'(3x,5(g0,"_wp, "),"&")')        (globpar(i),i= 6,10)
   write(id,'(3x,5(g0,"_wp, "),"&")')        (globpar(i),i=11,15)
   write(id,'(3x,5(g0,"_wp, "),"&")')        (globpar(i),i=16,20)
   write(id,'(3x,4(g0,"_wp, "),g0,"_wp /")') (globpar(i),i=21,25)

   do i = 1, max_elem
      do j = 1, max_elem
         if (abs(kpair(j,i)-1.0_wp).gt.1.0e-5_wp) then
            write(id,'("data NAME_pairparameter(",i0,",",i0,")/",1x,g0,"_wp /")') &
               j,i,kpair(j,i)
         endif
      enddo
   enddo

   do i = 1, max_elem
      write(id,'("data NAME_atomparameter(",i0,") / tb_parameter( & !",1x,a)') &
         &  i,toSymbol(i)
      call prelemdata_inc(id,'en',en(i))
      call prelemdata_inc(id,'mc',mc(i))
      call prelemdata_inc(id,'gam',gam(i))
      call prelemdata_inc(id,'gam3',gam3(i))
      call prelemdata_inc(id,'rad',rad(i))
      call prelemdata_inc(id,'wll',wll(i,:))
      call prelemdata_inc(id,'rep',rep(:,i))
      call prelemdata_inc(id,'polyr',polyr(:,i))
      call prelemdata_inc(id,'cxb',cxb(i))
      call prelemdata_inc(id,'ao_exp',ao_exp(:,i))
      call prelemdata_inc(id,'ao_lev',ao_lev(:,i))
      call prelemdata_inc(id,'lpar',lpar(:,i))
      call prelemdata_inc(id,'kcnat',kcnat(:,i))
      call prelemdata_inc(id,'radaes',radaes(i))
      call prelemdata_inc(id,'dpolc',dpolc(i))
      call prelemdata_inc(id,'qpolc',qpolc(i))
      call prelemdata_inc(id,'ao_pqn',ao_pqn(:,i))
      call prelemdata_inc(id,'ao_l',ao_l(:,i))
      call prelemdata_inc(id,'ao_n',ao_n(i))
      call prelemdata_inc(id,'ao_typ',ao_typ(:,i))
      call prelemdata_inc(id,'metal',metal(i))
      call prelemdata_inc(id,'cnval',cnval(i))
      ! print at the end, because it closes the parameter block (this is a hack)
      call prelemdata_inc(id,'timestp',timestp(i))
   enddo

   write(id,'("!!",1x,72("="))')
   write(id,'("!! generated by prelemparam in printout.f90 from libxtb.a on",1x,a)') &
   prtimestring('N')
   call close_file(id)

end subroutine prelemparam_inc

subroutine prelemdata_inc_string(id,name,data)
   implicit none
   integer,intent(in) :: id
   character(len=*),intent(in) :: name
   character(len=*),intent(in) :: data
   write(id,'(3x,a,1x,"=",1x)',advance='no') name
   write(id,'("''",a,"''")',advance='no') data
   write(id,'(")/")')
end subroutine prelemdata_inc_string

subroutine prelemdata_inc_int(id,name,data)
   implicit none
   integer,intent(in) :: id
   character(len=*),intent(in) :: name
   integer,intent(in) :: data
   write(id,'(3x,a,1x,"=",1x)',advance='no') name
   write(id,'(i0)',advance='no') data
   write(id,'(", &")')
end subroutine prelemdata_inc_int

subroutine prelemdata_inc_real(id,name,data)
   implicit none
   integer,intent(in) :: id
   character(len=*),intent(in) :: name
   real(wp),intent(in) :: data
   write(id,'(3x,a,1x,"=",1x)',advance='no') name
   write(id,'(g0,"_wp")',advance='no') data
   write(id,'(", &")')
end subroutine prelemdata_inc_real

subroutine prelemdata_inc_int_array(id,name,data)
   implicit none
   integer,intent(in) :: id
   character(len=*),intent(in) :: name
   integer,intent(in) :: data(:)
   integer :: i
   write(id,'(3x,a,1x,"=",1x,"(/")',advance='no') name
   do i = 1, size(data,1)-1
      write(id,'(i0,",",1x)',advance='no') data(i)
   enddo
   write(id,'(i0)',advance='no') data(size(data,1))
   write(id,'("/), &")')
end subroutine prelemdata_inc_int_array

subroutine prelemdata_inc_real_array(id,name,data)
   implicit none
   integer,intent(in) :: id
   character(len=*),intent(in) :: name
   real(wp),intent(in) :: data(:)
   integer :: i
   write(id,'(3x,a,1x,"=",1x,"(/")',advance='no') name
   do i = 1, size(data,1)-1
      write(id,'(g0,"_wp",",",1x)',advance='no') data(i)
   enddo
   write(id,'(g0,"_wp")',advance='no') data(size(data,1))
   write(id,'("/), &")')
end subroutine prelemdata_inc_real_array

!! ---------------------------------------------------------------[FB1808]-
subroutine writecosmofile(np,pa,espe,fname,nat,at,xyz,atom_weight)
   use xtb_mctc_accuracy, only : wp
   use xtb_mctc_convert, only : autoaa
   use xtb_mctc_symbols, only : toLcSymbol, toSymbol
   implicit none
   integer, intent(in)             :: np
   real(wp), intent(in)            :: pa(3,np)
   real(wp), intent(in)            :: espe(np)
   integer, intent(in)             :: at(nat)
   real(wp), intent(in)            :: xyz(3,nat)
   integer, intent(in)             :: nat
   character(len=*),intent(in)     :: fname
   real(wp),intent(in)             :: atom_weight(2,np)
   logical                         :: exist
   integer                         :: id, i

   call open_file(id,fname,'w')
   write(id,'(a)') '$coord_car'
   write(id,'(a,/,a)') '!BIOSYM archive 3','coordinates from COSMO calculation'
   do i=1,nat
      write(id,'("X1",1x,3f22.14,1x,"COSM 1",1x,a,1x,a,1x,"0.000")')&
         xyz(:,i)*autoaa,toLcSymbol(at(i)),toSymbol(at(i))
   enddo
   write(id,'(a)') 'end'
   write(id,'(a)') '$segment_information'
   do i=1,np
      write(id,'(2x,i5,2x,i0,4f22.14,1x,f22.14,1x,f22.14,1x,"0.000")')&
         i,int(atom_weight(1,i)), pa(:,i)*autoaa,espe(i)/10, &
         atom_weight(2,i)*100,espe(i)/10
   enddo
   call close_file(id)

end subroutine writecosmofile

subroutine setup_summary(iunit,n,fname,xcontrol,nargs,argument_list,wfx,xrc,exist)
   use xtb_mctc_accuracy, only : wp
   use xtb_mctc_systools
   use xtb_type_wavefunction
   use xtb_argparser
   use xtb_setparam
   !$ use omp_lib
   implicit none
   type(TWavefunction),intent(in) :: wfx
   integer, intent(in) :: iunit
   integer, intent(in) :: nargs
   type(string),intent(in) :: argument_list(nargs)
   character(len=*),intent(in) :: xrc
   character(len=*),intent(in) :: xcontrol
   character(len=*),intent(in) :: fname
   integer :: i,l,err
   integer,intent(in) :: n
   logical,intent(in) :: exist
   real(wp) :: dum5
   character(len=:),allocatable :: cdum
   write(iunit,'(a)')
   call generic_header(iunit,'Calculation Setup',49,10)
   write(iunit,'(a)')
   if (allocated(cdum)) deallocate(cdum)
   call get_command(length=l)
   allocate( character(len=l) :: cdum )
   call get_command(cdum)
   if (verbose) then
      i = index(cdum,' ')
      write(iunit,'(10x,a,":",1x,a)') 'command line arguments for ',cdum(:i-1)
      do i = 1, nargs
         write(iunit,'(12x,"->",i4,1x,"is",1x,a)') i,argument_list(i)%val
      enddo
   else
      write(iunit,'(10x,a,":",1x,a)') 'program call               ',cdum
   endif
   call rdvar('HOSTNAME',cdum,err)
   if (err.eq.0) &
      write(iunit,'(10x,a,":",1x,a)') 'hostname                   ',cdum
   if (allocated(xenv%namespace)) &
      write(iunit,'(10x,a,":",1x,a)') 'calculation namespace      ',xenv%namespace
   ! ----------------------------------------------------------------------
   !  print the home and path to check if there are set correctly
   write(iunit,'(10x,a,":",1x,a)') 'coordinate file            ',fname
   if (verbose) then
      write(iunit,'(10x,a,":",1x,a)') 'xtbhome directory          ',xenv%home
      write(iunit,'(10x,a,":",1x,a)') 'path for xtb               ',xenv%path
      write(iunit,'(10x,a,":",1x,a)') 'xcontrol input file        ',xcontrol
      if (exist) &
         write(iunit,'(10x,a,":",1x,a)') 'global configurations file ',xrc
   endif
   ! ----------------------------------------------------------------------
   !  technical data
   !$omp parallel
   !$omp master
   !$ write(iunit,'(10x,a,":",6x,i16)') 'omp threads                ',omp_get_num_threads()
   !$omp end master
   !$omp end parallel
   ! ----------------------------------------------------------------------
   !  print more specific calculation data
   write(iunit,'(10x,a,":",6x,i16)')   'number of atoms            ',n
   write(iunit,'(10x,a,":",6x,i16)')   'number of electrons        ',wfx%nel
   write(iunit,'(10x,a,":",6x,i16)')   'charge                     ',ichrg
   write(iunit,'(10x,a,":",6x,f16.1)') 'spin                       ',0.5_wp*wfx%nopen
   call random_number(dum5)
   write(iunit,'(10x,a,":",6x,f16.14)') 'first test random number   ',dum5
   if (verbose) then
      write(iunit,'(10x,a,":",12x,"0x",z8)') 'a pointer address          ',real(dum5,sp)
      write(iunit,'(10x,a,":",6x,z16)') 'random memory content      ',dum5
   endif
   if (veryverbose) then
      write(iunit,'(10x,a,":",20x,a)') 'is this your card?         ',"🃓"
      write(iunit,'(10x,a,":",15x,"so true")')'this was released?         '
   endif
   write(iunit,'(a)')

end subroutine

end module xtb_printout
